#!/usr/local/bin/perl
#
# dtsort.pl
# A. de la Fuente  13-Jan-1995
# Translated from dtsort.awk
#
eval "exec /usr/local/bin/perl -S $0 $*"
    if $running_under_some_shell;
			# this emulates #! processing on NIH machines.
			# (remove #! line above if indigestible)

eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
			# process any FOO=bar switche


$countrycodefile = "/vendor/webhead/WWW/docs/WWWVL/Astronomy/astroweb/country-codes";

#!/usr/local/bin/gawk -f
#
# Use: dtsort [-v tail=filename1.html] 
#                     [-v keys=filename2.html]
#                          [-v sort={protoname|topzone|name}]
#                              <input_file.html >sorted_file.html
#
# Program dtsort sorts <DT>-style resource records into "JANET" or
# "protocol"order. It also applies certain transformation rules, such
# as changing all SGML/HTML codes to uppercase and suppressing
# trailing blanks. In addition, it deletes exact duplicate resource
# records, and concatenates similar records by using <DL>..</DL> to
# indent.  
#
# Optional file 'tail' is nserted into the 'sorted_file' just before
# the final </BODY></HTML>. <ADDRESS> lines can be appended with this
# technique. Optional file 'keys' will contain a listing of the sort
# keys (the JANET-style values). 
#
# D.Wells, NRAO-CV, 11Feb-10Mar94,Jly94.
# todo: 
#      *change news:/janet logic so news will sort properly.
# --------------------------------------------------------------------
$[ = 1;			# set array base to 1
$, = ' ';		# set output field separator
$\ = "\n";		# set output record separator

$tail_file = $tail;
if ($sort eq '') {
    $sort = 'topzone';
    #
    ;
}

&to_lower('');
#   Copy input header lines up to first blank, then append comment:
while (($_ = &Getline0(),$getline_ok) > 0) {
    if (length > 0) {
	print $_;
    }
    else {
	last;
    }
}
$command = "echo \"" . sprintf('%12s',

  "'" . $sort . "'") . ' sort (`whoami`' .

  " on `hostname`. at `date`)\"";
$string = &Getline3($command, '|');
delete $opened{$command} && close($command);
printf "<!-- %s -->\n", $string;
# print comment to stdout
&Pick('|', 'cat 1>&2') &&
    (print $fh $string);
#  also to stderr (shows on terminal) 
printf (("\n<DL>\n"));
#
if ($kf = ($Keys ne '')) {
    $key_file = $Keys;
    &Pick('>', $key_file) &&
	(print $fh '<HTML><HEAD>');
    &Pick('>>', $key_file) &&
	(print $fh '<TITLE>Sort Keys for Master List</TITLE>');
    &Pick('>>', $key_file) &&
	(printf $fh "<!-- %s -->\n", $string);
    &Pick('>>', $key_file) &&
	(print $fh '</HEAD><BODY>');
    &Pick('>>', $key_file) &&
	(printf $fh "Sort-keys are intended to be in '%s' order:</P>\n", 
    $sort);
    &Pick('>>', $key_file) &&
	(print $fh "<DL>\n");
}

# --------------------------------------------------------------------
# Canonical resource records begin with blank line followed by <DT>.
# Therefore, we skip all input lines until we get a left-justified <DT>,
# then we concatenate the resource record lines, up to the next blank line:

line: while (<>) {
    chop;	# strip record separator
    @Fld = split(' ', $_, 9999);
    if ($_ =~ /^[<][Dd][Tt][>]/) {
	$r = $_ . '||';

	while (($_ = &Getline0(),$getline_ok)) {
	    if (length > 0) {
		$r = $r . $_ . '||';
	    }
	    else {
		last;
		# The lines of this resource are now concatenated into one string,
		# separated by the code '||':
		;
	    }
	}
	$n++;
	$resource{$n} = $r;
    }
    # --------------------------------------------------------------------
    # When reach EOF, edit each resource into canonical form, use keys[] to
    # sort the resource records, then delete duplicates and merge similar 
    # resources, and finally print the resources to stdout:  
    # ------------------------------------------------------------------
    # Replace 'pattern' in resource[l] with 'string' and set 'flag':
    # ------------------------------------------------------------------
}

&Pick('|', 'cat 1>&2') &&
    (printf $fh "%4d resource records read.\n", $n);
# Edit resource records into canonical form:
$num_edit = 0;
for ($l = 1; $l <= $n; $l++) {	#???
    $flag = 0;
    &replace_pattern(" +\\|\\|", '||');
    &replace_pattern("\\|\\| +", '||');
    # temporary rule?
    &replace_pattern("\"file://", "\"ftp://");
    &replace_pattern('  -->', ' -->');
    &replace_pattern('<!--  >', '<!-- ');
    &replace_pattern(' +<!--', '||<!--');
    if ($flag) {
	$num_edit++;
    }
}
if ($num_edit > 0) {
    &Pick('|', 'cat 1>&2') &&
	(printf $fh "%4d resource records edited:\n", $num_edit);
    foreach $i (keys %hit) {
	&Pick('|', 'cat 1>&2') &&
	    (printf $fh "\t%4d cases of |%s|\n", $hit{$i}, $i);
    }
}
#
# Following table specifies the sort_order for protocol sorts:
$k = 0;
$ps{'http'} = ++$k;
$ps{'gopher'} = ++$k;
$ps{'wais'} = ++$k;
$ps{'rlogin'} = $ps{'telnet'} = ++$k;
$ps{'file'} = ++$k;
$ps{'news'} = ++$k;
$ps{'mailto'} = ++$k;
#
# Construct sort keys for the resource records:
for ($l = 1; $l <= $n; $l++) {	#???
    $rr = $resource{$l};
    $u1 = ($rr =~ "[Hh][Rr][Ee][Ff]=\"" &&

      ($RLENGTH = length($&), $RSTART = length($`)+1)) + 6;
    # find start of first URL
    if ($u1 == 0) {
	&Pick('|', 'cat 1>&2') &&
	    (printf $fh "\nBad URL! n=%d, resource=[%s]\n\n", 
	($n + 1), substr($rr, 1, 40));
	next;
    }
    $ul = index(substr($rr, $u1, 999999), "\"") - 1;
    # get its length
    $url = substr($rr, $u1, $ul);
    $urls{$l} = $url;
    #       We have the URL string; we will parse it to construct a sort key
    #           in JANET style, with top-level domain first:
    if (substr($url, 1, 5) eq 'news:') {
	$protocol = substr($url, 1, 4);
	$janet = substr($url, 1, 4) . '.' . substr($url, 6, 999999);
	# a special case

	;
    }
    else {
	if (substr($url, 1, 7) eq 'mailto:') {
	    $protocol = substr($url, 1, 6);
	    $janet = substr($url, 1, 6) . '.' . substr($url, 8, 999999);
	    # another special case

	    ;
	}
	else {
	    $i = index($url, '://');
	    if ($i == 0) {
		&Pick('|', 'cat 1>&2') &&
		    (printf $fh "\nBad URL! n=%d, URL=[%s]\n\n", 
		($n + 1), substr($url, 1, 40));
		next;
	    }
	    $protocol = substr($url, 1, $i - 1);
	    # get protocol code
	    $i += 3;
	    $janet = '';
	    while (substr($url, $i, 999999) =~ '[./:@]' &&

	      ($RLENGTH = length($&), $RSTART = length($`)+1)) {
		$janet = substr($url, $i, $RSTART - 1) . '.' . $janet;
		# concat swapped
		$i += $RSTART;
		$k = substr($url, $i - 1, 1);
		# test next character:
		if (($k eq '/') || ($k eq ':')) {	#???	#???
		    last;
		    # quits after address
		    ;
		}
	    }
	}
    }
    if ($sort eq 'topzone') {
	$this_key = $janet . $protocol . substr($url, $i - 1, 999999);
    }
    elsif ($sort eq 'protoname') {
	#               "protoname" sorts on protocol+<A>name_string</A>:
	$a1 = index($rr, "\">||") + 4;
	$al = index(substr($rr, $a1, 999999), '||</A>') - 1;
	$resource_name = &to_lower(substr($rr, $a1, $al));
	$this_key = $ps{$protocol} . '_' . $protocol . '.' . $resource_name;
    }
    elsif ($sort eq 'name') {
	$a1 = index($rr, "\">||") + 4;
	$al = index(substr($rr, $a1, 999999), '||</A>') - 1;
	$resource_name = &to_lower(substr($rr, $a1, $al));
	$this_key = 'n.' . $resource_name;
    }
    else {
	&Pick('|', 'cat 1>&2') &&
	    (printf $fh "option 'sort' == '%s'. Unrecognized! ABORT.\n", 
	$sort);
	exit (13);
    }
    $a{$l} = $l;
    $Keys{$a{$l}} = $this_key;
}
#   printf ("     The '%s'-sort keys have been generated.\n", sort) | "cat 1>&2";
#
# shellsort {see Sedgewick "Algorithms in C" (A-W 1990), Ch.8, p.109,
#            also see Knuth "Sorting & Searching" (Vol.3), pp.84-95}.
#   Algorithm 'D' is not stable -- see Exercise5.1.2#8, p.102&598 of KnuthVol3,
#   so we add subscript suffix to keys to assure stable sort:
for ($l = 1; $l <= $n; $l++) {	#???
    $Keys{$a{$l}} = $Keys{$a{$l}} . sprintf('%05d', $l);
}
$num_moves = 0;
for ($h = 1; $h <= int($n / 9); $h = 3 * $h + 1) {
    ;
}
for (; $h > 0; $h = int($h / 3)) {
    for ($k = 0; $k < $h; $k++) {	#???
	for ($i = $h + 1 + $k; $i <= $n; $i += $h) {	#???
	    $v = $Keys{$v_a = $a{$i}};

	    $j = $i;
	    while (($j > $h) && ($Keys{$a{$j - $h}} gt $v)) {	#???	#???
		$a{$j} = $a{$j - $h};
		$j -= $h;
		$num_moves++;
	    }
	    $a{$j} = $v_a;
	}
	#   remove subscript suffixes:
	;
    }
}
for ($l = 1; $l <= $n; $l++) {	#???
    $Keys{$a{$l}} = substr($Keys{$a{$l}}, 1, length($Keys{$a{$l}}) - 5);
    #   printf("%4d pointer-moves done by shellsort.\n", num_moves) | "cat 1>&2"; 
    #
    # Delete identical (same URL, same text) resources:
    ;
}
$num_delete = 0;
$i = 0;
for ($l = 1; $l < $n; $l++) {	#???
    if ($resource{$a{$l}} ne $resource{$a{$l + 1}}) {	#???
	$a{++$i} = $a{$l};
    }
    else {
	$num_delete++;
    }
}
$a{++$i} = $a{$n};
$n = $i;
if ($num_delete > 0) {
    &Pick('|', 'cat 1>&2') &&
	(printf $fh "%4d identical resource records deleted. (n=%d)\n", 
    $num_delete, $n);
    #
    # Merge cases of identical URLs but different text:
    ;
}
$num_merge = 0;
$num_multiple = 0;
$num_somebody = 0;
$i = 0;
for ($l = 1; $l < $n; $l++) {	#???
    $somebody_flag = 0;
    if (($Keys{$a{$l}} eq $Keys{$a{$l + 1}}) && 	#???
    ($resource{$a{$l}} ne $resource{$a{$l + 1}})) {	#???
#	if ($resource{$a{$l}} =~ "<!-- OWNER \?\?\? -->\\|\\|" &&
	if ($resource{$a{$l}} =~ /<!-- OWNER \?\?\? -->/ &&
	  ($RLENGTH = length($&), $RSTART = length($`)+1)) {
	    #               Test for special "???" (somebody) case:
	    if ((substr($resource{$a{$l}}, 1,
	      $RSTART - 1) . substr($resource{$a{$l}}, $RSTART + $RLENGTH,
	      999999)) eq $resource{$a{$l + 1}}) {	#???
		$resource{$a{$l + 1}} = $resource{$a{$l}};
		$num_merge++;
		$num_somebody++;
		$somebody_flag = 1;
	    }
	}
	if (!$somebody_flag) {
	    #           append resource[a[l+1]] to [l], <DL> makes indentation:
	    if ($resource{$a{$l}} =~ "</DL>\\|\\|\$" &&

	      ($RLENGTH = length($&), $RSTART = length($`)+1)) {
		$resource{$a{$l + 1}} = substr($resource{$a{$l}}, 1,

		  $RSTART - 1) . $resource{$a{$l + 1}} . '</DL>||';

		$num_multiple++;
	    }
	    else {
		$resource{$a{$l + 1}} = $resource{$a{$l}} .

		  '<DL><EM>The following resources are similar ' .

		  '(same sort-key, different text):</EM>||' . $resource{$a{$l

		  + 1}} . '</DL>||';
	    }
	    $num_merge++;
	}
    }
    else {
	$a{++$i} = $a{$l};
    }
}
$a{++$i} = $a{$n};
$n = $i;
if ($num_merge > 0) {
    &Pick('|', 'cat 1>&2') &&
	(printf $fh

	  "%4d   similar resource records  merged. (n=%d) %d multiple, %dsomebody\n",

	  $num_merge, $n, $num_multiple, $num_somebody);
    #
    # following table gives comment strings for selected top-level domains:
    ;
}

#read in table of ISO codes and country names 

open (blah, "<$countrycodefile") || die "Can't open $countrycodefile";
while (<blah>) {
      chop;
      local($iso,$name)=split('   ');
      $iso =~ y/A-Z/a-z/;
      $tld{"$iso"}="$name";
}
close blah;
#
$tld{'1_http'} = 'World Wide Web';
$tld{'2_gopher'} = 'Gopher';
$tld{'3_wais'} = 'Wide Area Information Services';
$tld{'4_rlogin'} = $tld{'4_telnet'} = 'Remote Login';
$tld{'5_file'} = 'Anonymous-FTP [File Transfer Protocol]';
$tld{'6_news'} = 'USEnet_Newsgroups';
$tld{'7_mailto'} = 'Email exploders';
#
# print the sorted resource records:
$last_top = '';
for ($l = 1; $l <= $n; $l++) {	#???
    $this_key = $Keys{$a{$l}};
    $top = substr($this_key, 1, index($this_key, '.') - 1);
    if ($top ne $last_top) {	#???
	if ($topcom = (defined $tld{$top})) {
	    $topcom = $tld{$top};
	}
	else {
	    $topcom = '';
	}
	$text = '2';
	$text = "</DL>\n<HR><H" . $text . '>' . $top . ' (' . $topcom . ')</H'

	  . $text . "><HR>\n<DL>\n\n";
	print $text;
	if ($kf) {
	    &Pick('>>', $key_file) &&
		(print $fh $text);
	}
	$last_top = $top;
    }
    $this_resource = $resource{$a{$l}};

    while (length($this_resource) > 0) {
	$p = index($this_resource, '||');
	# find end of current line
	printf "%s\n", substr($this_resource, 1, $p - 1);
	# print it
	$this_resource = substr($this_resource, $p + 2, 999999);
	# and delete it.

	;
    }
    printf (("\n"));
    #
    if ($kf) {
	&Pick('>>', $key_file) &&
	    (printf $fh "<DT>\n<A HREF=\"%s\">\n%s\n</A></DT>\n\n", 
	$urls{$a{$l}}, $Keys{$a{$l}});
    }
}
print '</DL>';
if ($tail_file ne '') {
    $num_tail = 0;
    while (($_ = &Getline2($tail_file),$getline_ok) > 0) {
	print $_;
	$num_tail++;
    }
    delete $opened{$tail_file} && close($tail_file);
    #       printf ("%4d lines copied from %s.\n", num_tail, tail_file) | "cat 1>&2";

    ;
}
print '</BODY>';
print '</HTML>';
&Pick('|', 'cat 1>&2') &&
    (printf $fh "%4d resource records written.\n", $n);
#
if ($kf) {
    &Pick('>>', $key_file) &&
	(print $fh '</DL></BODY></HTML>');
    delete $opened{$key_file} && close($key_file);
}

exit $ExitValue;

sub replace_pattern {
    local($pattern, $string) = @_;
    $num_hits = 0;
    while ($resource{$l} =~ $pattern &&

      ($RLENGTH = length($&), $RSTART = length($`)+1)) {
	$matched = substr($resource{$l}, $RSTART, $RLENGTH);
	$hit{$matched}++;
	$num_hits++;
	if ($num_hits > 30) {
	    &Pick('|', 'cat 1>&2') &&
		(printf $fh

		  "TOO MANY HITS? l=%3d,RS=%3d,RL=%2d,pat=|>%s<| matches |>%s<|\n",

		  
	    $l, $RSTART, $RLENGTH, $pattern, $matched);
	    # exit(13);

	    ;
	}
	$hit{substr($resource{$l}, $RSTART, $RLENGTH)}++;
	$resource{$l} = substr($resource{$l}, 1,

	  $RSTART - 1) . $string . substr($resource{$l}, $RSTART + $RLENGTH,

	  999999);
	$flag = 1;
    }
}

sub to_lower {
    local($string) = @_;
    if ($string eq '') {	#???
	$lc{'A'} = 'a';
	$lc{'B'} = 'b';
	$lc{'C'} = 'c';
	$lc{'D'} = 'd';
	$lc{'E'} = 'e';
	$lc{'F'} = 'f';
	$lc{'G'} = 'g';
	$lc{'H'} = 'h';
	$lc{'I'} = 'i';
	$lc{'J'} = 'j';
	$lc{'K'} = 'k';
	$lc{'L'} = 'l';
	$lc{'M'} = 'm';
	$lc{'N'} = 'n';
	$lc{'O'} = 'o';
	$lc{'P'} = 'p';
	$lc{'Q'} = 'q';
	$lc{'R'} = 'r';
	$lc{'S'} = 's';
	$lc{'T'} = 't';
	$lc{'U'} = 'u';
	$lc{'V'} = 'v';
	$lc{'W'} = 'w';
	$lc{'X'} = 'x';
	$lc{'Y'} = 'y';
	$lc{'Z'} = 'z';
    }
    else {
	$lower_string = '';
	for ($lci = 1; $lci <= length($string); $lci++) {
	    $cc = substr($string, $lci, 1);
	    if (defined $lc{$cc}) {
		$cc = $lc{$cc};
	    }
	    $lower_string = $lower_string . $cc;
	}
    }
    ($lower_string);
}

sub Getline0 {
    if ($getline_ok = (($_ = <>) ne '')) {
	chop;	# strip record separator
	@Fld = split(' ', $_, 9999);
    }
    $_;
}

sub Getline2 {
    &Pick('',@_);
    if ($getline_ok = (($_ = <$fh>) ne '')) {
	chop;	# strip record separator
	@Fld = split(' ', $_, 9999);
    }
    $_;
}

sub Getline3 {
    &Pick('',@_);
    local($_);
    if ($getline_ok = (($_ = <$fh>) ne '')) {
	chop;	# strip record separator
    }
    $_;
}

sub Pick {
    local($mode,$name,$pipe) = @_;
    $fh = $name;
    open($name,$mode.$name.$pipe) unless $opened{$name}++;
}
